Unit MemoryMapDataShare;

Interface

Uses Classes, SysUtils, Windows, CodesiteLogging;

Type
  pMemShareHead = ^TMemShareHead;
  TMemShareHead = Packed Record
    iSize: LongWord;
  End;

Type
  TMemoryMapDataShare = Class(TComponent)
  Private
    fFileMapObjHead, fFileMapObj: THandle;
    fShareName, fShareNameHead: String;
    lwSize: pMemShareHead;
    shareInt: pInteger;
    ShareStr: pChar;
    ShareStream: Pointer;
    fActive: Boolean;

    fMutex: Boolean;
    hMutex: THandle;
    fMutexName: String;
    sa: TSecurityAttributes;
    sd: TSecurityDescriptor;

    Function GetActive: Boolean;
    Function DoOpenMutex: Boolean;
    Procedure DoCloseMutex;

    Procedure SetShareName(Const Value: String);
    Procedure SetShareDataSize(Const Value: LongWord);
    Function GetShareDataSize: LongWord;
    Procedure InitSecAttr(Var sa: TSecurityAttributes; Var sd: TSecurityDescriptor);
    Procedure setMutex(Const Value: Boolean);
    Procedure WaitLock;
    Procedure UnLock;

  Protected

    Function DoOpenHead: Boolean;
    Procedure DoCloseHead;

    Function DoOpen: Boolean;
    Procedure DoClose;
  Public
    Procedure WriteString(src: String);
    Procedure WriteInteger(src: Integer);
    Procedure WriteStream(Var src: TMemoryStream);

    Function ReadString: String;
    Function ReadInteger: Integer;
    Procedure ReadStream(stream: TMemoryStream);

    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;

    Function Open: Boolean;
    Procedure close;

    Property Active: Boolean Read GetActive;
  Published
    Property ShareName: String Read fShareName Write SetShareName;
    Property ShareDataSize: LongWord Read GetShareDataSize Write SetShareDataSize;
    Property MuTex: Boolean Read fMutex Write setMutex;
  End;

Implementation

{ TMemShareData }

Constructor TMemoryMapDataShare.Create(AOwner: TComponent);
Begin
  Inherited;
  fActive := False;
  fFileMapObj := 0;
  fFileMapObjHead := 0;
  ShareInt := Nil;
  ShareStr := Nil;
  fMutex := False;
  self.ShareName := 'MemoryMappedShareData' + intToStr(GetTickCount);
End;

Destructor TMemoryMapDataShare.Destroy;
Begin
  DoCloseHead;
  DoClose;
  DoCloseMutex;
  Inherited;
End;

Procedure TMemoryMapDataShare.DoClose;
Begin
  If fFileMapObj <> 0 Then
  Begin
    CloseHandle(fFileMapObj);
    fFileMapObj := 0;
  End;

  fActive := False;
End;

Procedure TMemoryMapDataShare.DoCloseHead;
Begin
  If fFileMapObjHead <> 0 Then
  Begin
    CloseHandle(fFileMapObjHead);
    fFileMapObjHead := 0;
  End;
End;

Function TMemoryMapDataShare.DoOpenHead: Boolean;
Begin
  Result := False;
  If fFileMapObjHead <> 0 Then
  Begin
    Result := True;
    exit;
  End;

  Try
    WaitLock;
    fFileMapObjHead := CreateFileMapping($FFFFFFFF, Nil, PAGE_READWRITE, 0, sizeof(TMemShareHead), pChar(fShareNameHead));
    If fFileMapObjHead = 0 Then
    Begin
      If GetLastError = ERROR_ALREADY_EXISTS Then
      Begin
        fFileMapObjHead := OpenFileMapping(FILE_MAP_WRITE Or FILE_MAP_READ, False, pchar(fShareNameHead));
        If fFileMapObjHead = 0 Then
        Begin
{$IFDEF debug}
          CodeSite.Send('TMemShareData - Open Head Error : %s  ', [sysutils.SysErrorMessage(GetLastError)]);
{$ENDIF}
          RaiseLastOSError;
        End;
      End
      Else
      Begin
{$IFDEF debug}
        CodeSite.Send('TMemShareData - Open Head Error : %s  ', [sysutils.SysErrorMessage(GetLastError)]);
{$ENDIF}
        RaiseLastOSError;
        exit;
      End;
    End;
  Finally // wrap up
    UnLock;
  End; // try/finally

  Result := (fFileMapObjHead <> 0);

End;

Function TMemoryMapDataShare.DoOpen: Boolean;
Var
  DataSize: LongWord;
Begin
  fActive := False;

  Result := False;
  If fFileMapObjHead = 0 Then
    DoOpenHead;

  DataSize := self.ShareDataSize;

  If fFileMapObj <> 0 Then
    CloseHandle(fFileMapObj);
  Try
    WaitLock;

    fFileMapObj := CreateFileMapping($FFFFFFFF, Nil, PAGE_READWRITE, 0, DataSize, pChar(fShareName));
    If fFileMapObj = 0 Then
    Begin
      If GetLastError = ERROR_ALREADY_EXISTS Then
      Begin
        fFileMapObj := OpenFileMapping(FILE_MAP_WRITE Or FILE_MAP_READ, False, pchar(fShareName));
      End
      Else
      Begin
{$IFDEF debug}
        CodeSite.Send('TMemShareData - Open Error : %s  ', [sysutils.SysErrorMessage(GetLastError)]);
{$ENDIF}

        RaiseLastOSError;
        exit;
      End;
    End;
  Finally // wrap up
    UnLock;
  End; // try/finally

  Result := (fFileMapObj <> 0);
  fActive := Result;
End;

Function TMemoryMapDataShare.GetActive: Boolean;
Begin
  Result := fActive;
End;

Function TMemoryMapDataShare.GetShareDataSize: LongWord;
Begin
  If fFileMapObjHead = 0 Then
    If Not DoOpenHead Then exit;
  lwSize := MapViewofFile(fFileMapObjHead, FILE_MAP_READ, 0, 0, 0);
  If Assigned(lwSize) Then
  Begin
    Result := lwSize^.iSize;
    UnmapViewOfFile(lwSize);
  End
  Else Result := 0;
End;

Procedure TMemoryMapDataShare.SetShareDataSize(Const Value: LongWord);
Begin
  If fFileMapObjHead = 0 Then
    If Not DoOpenHead Then exit;

  lwSize := MapViewOfFile(fFileMapObjHead, FILE_MAP_WRITE, 0, 0, 0);
  If Assigned(lwSize) Then
  Begin
    lwSize.iSize := Value;
    UnMapViewOfFile(lwSize);
  End
  Else
    Raise Exception.Create('MemoryMapped aread Access Fail.');
End;

Procedure TMemoryMapDataShare.SetShareName(Const Value: String);
Begin
  fShareName := Value;
  fShareNameHead := fShareName + '_Head';
  fMutexName := fShareName + '_Mutex';
  If fMutex Then
  Begin
    DoCloseMutex;
    DoOpenMutex;
  End;
End;

Procedure TMemoryMapDataShare.WriteInteger(src: Integer);
Var
  size: Longword;
Begin
  Size := self.ShareDataSize;
  If Size <> sizeof(Integer) Then
  Begin
    self.ShareDataSize := sizeof(Integer);
    doClose;
    doOPen;
  End;

  Try
    WaitLock;

    ShareInt := MapViewoffile(fFileMapObj, FILE_MAP_WRITE, 0, 0, 0);
    If Assigned(ShareInt) Then
    Begin
      ShareInt^ := Src;
      UnmapViewOfFile(ShareInt);
    End
    Else
      Raise Exception.Create('MeomoryMapped area access Fail.(WriteInteger)');

  Finally // wrap up
    UnLock;
  End; // try/finally
End;

Function TMemoryMapDataShare.ReadInteger: Integer;
Begin
  doClose;
  doOPen;

  Result := 0;
  Try
    WaitLock;

    ShareInt := MapViewoffile(fFileMapObj, FILE_MAP_READ, 0, 0, 0);
    If Assigned(ShareInt) Then
    Begin
      Result := ShareInt^;
      UnmapViewOfFile(ShareInt);
    End
    Else
      Raise Exception.Create('MeomoryMapped area access Fail.(ReadInteger)');

  Finally // wrap up
    UnLock;
  End; // try/finally
End;

Function TMemoryMapDataShare.ReadString: String;
Var
  size: Longword;
Begin
  doClose;
  doOPen;

  Try
    WaitLock;

    ShareStr := MapViewoffile(fFileMapObj, FILE_MAP_READ, 0, 0, 0);
    If Assigned(ShareStr) Then
    Begin
      Result := ShareStr;
      UnmapViewOfFile(ShareStr);
    End
    Else
      Raise Exception.Create('MeomoryMapped area access Fail.(ReadString)');

  Finally // wrap up
    UnLock;
  End; // try/finally

End;

Procedure TMemoryMapDataShare.close;
Begin
  self.DoClose;
End;

Function TMemoryMapDataShare.Open: Boolean;
Begin
  Result := self.DoOpen;
End;

Procedure TMemoryMapDataShare.WriteString(src: String);
Var
  size: Longword;
Begin
  Size := self.ShareDataSize;
  If Size <> Length(src) Then
  Begin
    self.ShareDataSize := Length(src);
    doclose;
    doOPen;
  End;

  Try
    WaitLock;

    ShareStr := MapViewoffile(fFileMapObj, FILE_MAP_WRITE, 0, 0, 0);
    If Assigned(ShareStr) Then
    Begin
      StrpCopy(ShareStr, Src);
      UnmapViewOfFile(ShareStr);
    End
    Else
      Raise Exception.Create('MeomoryMapped area access Fail.(WriteString)');
  Finally // wrap up
    UnLock;
  End; // try/finally

End;

Procedure TMemoryMapDataShare.WriteStream(Var src: TMemoryStream);
Var
  size: Longword;
Begin
  Size := self.ShareDataSize;
  If Size <> src.Size Then
  Begin
    self.ShareDataSize := src.Size;
    doclose;
    doOPen;
  End;

  Try
    WaitLock;

    ShareStream := MapViewoffile(fFileMapObj, FILE_MAP_WRITE, 0, 0, 0);
    If Assigned(ShareStream) Then
    Begin
      src.Position := 0;

      CopyMemory(ShareStream, src.Memory, src.Size);
      UnmapViewOfFile(ShareStream);
    End
    Else
      Raise Exception.Create('MeomoryMapped area access Fail.(WriteStream)');

  Finally // wrap up
    UnLock;
  End; // try/finally
End;

Procedure TMemoryMapDataShare.ReadStream(stream: TMemoryStream);
Var
  size: Longword;
Begin
  Size := self.ShareDataSize;
  doclose;
  doOPen;

  Try
    WaitLock;

    ShareStream := MapViewoffile(fFileMapObj, FILE_MAP_READ, 0, 0, 0);
    If Assigned(ShareStream) Then
    Begin
      Stream.Size := Size;
      CopyMemory(Stream.Memory, ShareStream, Stream.Size);
      Stream.Position := 0;
      UnmapViewOfFile(ShareStream);
    End
    Else
      Raise Exception.Create('MeomoryMapped area access Fail.(WriteStream)');

  Finally // wrap up
    UnLock;
  End; // try/finally
End;

Procedure TMemoryMapDataShare.InitSecAttr(Var sa: TSecurityAttributes;
  Var sd: TSecurityDescriptor);
Begin
  sa.nLength := sizeOf(sa);
  sa.lpSecurityDescriptor := @sd;
  sa.bInheritHandle := false;
  InitializeSecurityDescriptor(@sd, SECURITY_DESCRIPTOR_REVISION);
  SetSecurityDescriptorDacl(@sd, true, Nil, false);
End;

Procedure TMemoryMapDataShare.setMutex(Const Value: Boolean);
Begin

  If (Not value) Then
  Begin
    DoCloseMutex;
  End;

  fMutex := Value;

  If value Then
  Begin
    DoOpenMutex;
  End;
End;

Function TMemoryMapDataShare.DoOpenMutex: Boolean;
Begin
  Result := false;

  If hMutex <> 0 Then closeHandle(hMutex);
  InitSecAttr(sa, sd);
  hMutex := CreateMutex(@sa, False, pchar(fMutexName));
  If hMutex = 0 Then
  Begin
    If (GetLastError = ERROR_ALREADY_EXISTS) Then
    Begin
      hMutex := OpenMutex(MUTEX_ALL_ACCESS, False, pchar(fMutexName));
      If hMutex = 0 Then
        RaiseLastOSError;
    End;
  End;

  Result := (hMutex <> 0);
End;

Procedure TMemoryMapDataShare.DoCloseMutex;
Begin
  If hMutex <> 0 Then
  Begin
    CloseHandle(hMutex);
    hMutex := 0;
  End;
End;

Procedure TMemoryMapDataShare.UnLock;
Begin
  If (Not fMutex) Or (hMutex = 0) Then exit;
  ReleaseMutex(hMutex);
End;

Procedure TMemoryMapDataShare.WaitLock;
Var
  RET: DWord;
  sp: LongWord;
Begin
  If (Not fMutex) Or (hMutex = 0) Then exit;
  sp := GetTickCount;
  RET := WaitForSingleObject(hMutex, 200);
  While True Do
  Begin
    If Ret = WAIT_OBJECT_0 Then break;
    If (GetTickcount - sp) > 1000 Then break;
    RET := WaitForSingleObject(hMutex, 200);
  End; // while
End;

End.

